home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Utilities / Text Utils / Alpha 5.81 ƒ / Tcl / SystemCode / procs.tcl < prev    next >
Encoding:
Text File  |  1994-07-07  |  10.8 KB  |  456 lines  |  [TEXT/ALFA]
  1. #==============================================================================
  2. proc normalLeftBracket {} {
  3.     insertText "\{"
  4. }
  5. proc normalRightBracket {} {
  6.     insertText "\}"
  7. }
  8. bind '\[' <zs>  normalLeftBracket
  9. bind '\]' <zs>  normalRightBracket
  10.             
  11. # Select the next or current word. If word already selected, will go to next.
  12. proc hiliteWord {} {
  13.     if {[getPos]!=[selEnd]}    forwardChar
  14.     forwardWord
  15.     set start [getPos]
  16.     backwardWord
  17.     select $start [getPos]
  18. }
  19.  
  20. bind 'h' <z> hiliteWord
  21.  
  22. #================================================================================
  23. # Mode variables
  24. #================================================================================
  25. # For mark stack.
  26. set markName 0
  27. set markStack ""
  28.  
  29. # mapping of windows to current modes.
  30. set winModes("") ""
  31.  
  32. # making vars local to windows
  33. # 'incomingVars' used to hold old var values that have been overwritten in current window
  34.  
  35. #================================================================================
  36. # Handle 'flag' and 'var' menu selections.
  37. #================================================================================
  38. proc editFlag {menu item} {
  39.     global $item incomingVars
  40.  
  41.     set val [expr ([set $item]-1)*-1]
  42.     markMenuItem $menu $item [expr ([set $item])?"on":"off"]
  43.     set $item $val
  44. }
  45.  
  46. proc editVar {menu item} {
  47.     global $item incomingVars
  48.  
  49.     append prmpt "New Value of " $item ": "
  50.     if ![catch {prompt $prmpt [set $item]} res] {
  51.         set $item $res
  52.     }
  53. }
  54.  
  55.  
  56.  
  57.  
  58. #================================================================================
  59.  
  60. # Instantiate a global variable to the path of a file (usually an app). As a
  61. # side-effect, make the instantiation permanent by adding a line to 'definitions.tcl'.
  62. proc addAppPath {name var} {
  63.     global $var
  64.     
  65.     if {[catch {getfile "Find '$name' app:"} path]} {return 1}
  66.     set $var $path
  67.  
  68.     addUserLine "set $var \"[quoteExpr2 $path]\""
  69.     return 0
  70. }
  71.  
  72. proc addUserLine {line} {
  73.     global HOME
  74.  
  75.     if {[file exists "$HOME:userStartup.tcl"]} {
  76.         set fid [open "$HOME:userStartup.tcl" "a"]
  77.     } else {
  78.         set fid [open "$HOME:userStartup.tcl" "w"]
  79.     }
  80.     puts $fid $line
  81.     close $fid
  82. }
  83.  
  84.  
  85. proc getFileSig {f} {
  86.     catch {lindex [ls -l $f] 5} var
  87.     return $var
  88. }
  89.  
  90.  
  91. # Look for given app sig in active processes. If not there, try to 
  92. # launch with 'path' prompting for 'path' if necessary.
  93. # Return the real name of the app. Don't switch.
  94. proc checkRunning {name sig path} {
  95.     global $path
  96.     foreach proc [processes] {
  97.         if {[lindex $proc 1] == $sig} {
  98.             return [lindex $proc 0]
  99.         }
  100.     }
  101.     if {![info exists $path] || ![file exists [set $path]]} {
  102.         if {[addAppPath $name $path]} return
  103.     }
  104.     if {[catch {getFileSig [set $path]}]} {
  105.         if {[addAppPath $name $path]} return
  106.     }
  107.     set sig [getFileSig [set $path]]
  108.     if {[catch {launch -f [set $path]}]} {
  109.         error "Problem with script."
  110.     }
  111.     return [file tail [set $path]]
  112. #    return [checkRunning $name $sig $path]
  113. }
  114.  
  115. #================================================================================
  116. # Excalibur is the only Mac spell-checker that I know of which will handle LaTeX as
  117. # well as ordinary text.
  118.  
  119.  
  120. proc spellcheckWindow {} {
  121.     global excaliburPath resumeRevert
  122.  
  123.     catch {checkRunning Excalibur XCLB excaliburPath} name
  124.  
  125.     if {[winInfo dirty]} {
  126.         if {[askyesno "Save '[lindex [winNames] 0]'?"] == "yes"} {
  127.             save
  128.         }
  129.     }
  130.     if {[catch {sendOpenEvent -n $name [lindex [winNames -f] 0]}] } {
  131.         beep 
  132.     } else {
  133.         switchTo $name
  134.     }
  135.     set resumeRevert 1
  136. }
  137.  
  138. proc spellcheckSelection {} {
  139.     global excaliburPath 
  140.  
  141.     catch {checkRunning Excalibur XCLB excaliburPath} name
  142.  
  143.     if {[getPos] == [selEnd]} {
  144.         beep
  145.         message "No selection"
  146.         return;
  147.     }
  148.     copy
  149.     switchTo $name
  150. }
  151.  
  152. #================================================================================
  153.  
  154.  
  155. proc alphaHelp {} {
  156.     global HOME
  157.     edit -r -m "$HOME:Help:Alpha Commands"
  158. }
  159.  
  160.  
  161. proc tclHelp {} {
  162.     global HOME
  163.     edit -r -m "$HOME:Help:Tcl Commands"
  164. }
  165.  
  166.  
  167. set patternLibrary {
  168.     { "Pascal to C Comments" {        \{([^\}]*)\}} {/* \1 */} }
  169.     { "C++ to C Comments" {//(.*)} {/* \1 */}}
  170. }
  171.  
  172.  
  173. proc dividingLine {} {
  174.     insertText "================================================================================\r"
  175. }
  176. bind 'l' <C> dividingLine
  177.  
  178. proc texDividingLine {} {
  179.     insertText "%================================================================================\r"
  180. }
  181. bind 'l' <C> texDividingLine TeX
  182.  
  183. proc cDividingLine {} {
  184.     insertText "//================================================================================\r"
  185. }
  186. bind 'l' <C> cDividingLine C
  187. bind 'l' <C> cDividingLine C++
  188.  
  189. proc tclDividingLine {} {
  190.     insertText "#================================================================================\r"
  191. }
  192. bind 'l' <C> tclDividingLine Tcl
  193.  
  194.  
  195. #================================================================================
  196.  
  197. if {[catch {info args oldCd}]} {
  198.     rename cd oldCd
  199. }
  200.  
  201. proc cd args {
  202.     global HOME
  203.     if {[llength $args]} {
  204.         oldCd [string trim [eval list $args] "        \{\}"]
  205.     } else {
  206.         oldCd $HOME
  207.     }
  208. }
  209.  
  210. #================================================================================
  211.  
  212. proc getVarValue {} {
  213.     set val [listpick -p {Which var?} [lsort [info globals]]]
  214.     if {![string length $val]} return
  215.     global $val
  216.     alertnote [join [list "'$val' = " [set $val]] ""]
  217. }
  218.  
  219. #================================================================================
  220.     
  221. proc selectParagraph {} {
  222.     set pos [getPos]
  223.     set start [paraStart $pos] 
  224.     set finish [paraFinish $pos]
  225.     goto $start
  226.     select $start $finish
  227. }
  228.  
  229. # wrapText ==  getText ; breakIntoLines ; replaceText
  230. # Remove text from window, transform (join, del-ws), insert back into window.
  231. proc fillTextByPar {from to} {
  232.     set text [getText $from $to]
  233.     regsub -all "\r(\[ \t\]*\r)+" $text "\r\r\r" text
  234.     regsub -all "(\[^\r\])\r" $text "\\1 " text
  235.     regsub -all "\[ \t\]+" $text " " text
  236.     return [breakIntoLines $text]
  237. }
  238.  
  239. proc fillRegionByPar {{start -1} {finish -1}} {
  240. #    # if {[getPos] == [selEnd]} { return}
  241.     if {($start < 0) || ($finish < 0)} {
  242.         set start [lineStart [getPos]]
  243.         set finish [selEnd] }
  244.     if {$start >= $finish} return
  245.     goto $start
  246.     set text [fillTextByPar $start $finish]
  247.     replaceText $start $finish $text "\r"
  248. }
  249.     
  250. #
  251. # join Lines in region -- if no optional args, use selection
  252. #
  253. proc joinRegion {{from -1} {to -1}} {
  254.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  255.     if {$from >= $to} return
  256.     set text [getText $from $to]
  257.     regsub -all "\r(\[ \t\]*\r)+" $text "\r\r\r" text
  258.     regsub -all "(\[^\r\])\r" $text "\\1 " text
  259.     replaceText $from $to $text "\r"
  260. }
  261. # WARNING:    regsub ^$ refers to string endpts (not lines)
  262. # FUTURE:    filterLines like perl:
  263. #    replaceText[apply_to_all(cmd,split [getText [getPos] [selEnd]] "\r")]
  264. # OR:    replaceInRegion: dup_\r, $=>\r ??
  265. #
  266.  
  267.  
  268. #
  269. # Remove text from window, transform (delete dup ws), insert back into window.
  270. #
  271. # inputs: message, alertnote, askyesno, listpick, prompt KILLS SELECTION.
  272. # search: bnds = search -forward -regExpr -ignoreCase -matchWords -noabort 
  273. #        -l limit pat pos
  274. # 
  275. proc regsubInRegion {from to srch repl} {
  276.     if {![string length $srch]} return
  277.     if {$from >= $to} return
  278.     set text [getText $from $to]
  279.     regsub -all "$srch" $text "$repl" text
  280.     replaceText $from $to $text
  281. }
  282. #    while {($pos < $to) &&
  283. #          ![catch {search -f 1 -r 1 -i 1 -m 0 "$srch" $pos} mtch]} {
  284. #        set mbeg [lindex $mtch 0]
  285. #        set pos [lindex $mtch 1]
  286. #        replaceText $mbeg $pos $repl }
  287.  
  288. #proc backSlashSub {arg} { eval [concat return "\"$arg\""] }
  289.  
  290. proc backSlashSub {arg} {
  291.     regsub -all {\\} $arg {\\\\} arg
  292.     regsub -all {\[} $arg {\\[} arg
  293.     regsub -all {\]} $arg {\\]} arg
  294.     eval [concat return "\"$arg\""]
  295. }
  296.  
  297. proc replaceInRegion {} {
  298.     if [catch {prompt "Search RegExpr:" ""} srch] return
  299.     if [catch {prompt "Replace String:" ""} repl] return
  300.     if {![string length $srch]} return
  301.     regsubInRegion [getPos] [selEnd] \
  302.         [backSlashSub "$srch"] [backSlashSub "$repl"]
  303. }
  304.  
  305. #
  306. # Apply command to each line (or paragraph) in selection ;
  307. #    if no cmd arg then prompts for it
  308. #
  309. proc filterLines {{cmd 0} {parunit 0}} {
  310.     if {$cmd == 0} {
  311.       if {[catch { prompt "Line-filter command: " "" } cmd]} { return } }
  312.     if {![string length $cmd]} return
  313.     set unitStart lineStart
  314.     set unitEnd nextLineStart
  315.     if {$parunit} {
  316.         set unitStart paraStart
  317.         set unitEnd paraFinish }
  318.     set pos [$unitStart [getPos]]
  319.     set finish [selEnd]
  320.     if {$pos >= $finish} return
  321.     goto $pos
  322.     createTMark "filterLend" $finish
  323.     set next [$unitEnd $pos]
  324.     while {(($next > $pos) && ($pos < $finish))} {
  325.         goto [expr $next-1]
  326.         createTMark "filterLnext" $next
  327.         setMark
  328.         goto $pos
  329.         markHilite
  330.         if {[catch [list uplevel #0 "$cmd"] retval]} {
  331.             select $pos $finish
  332.             alertnote $retval
  333.             return
  334.         }
  335.         if {$next==$finish} break
  336.         set ind [lsearch -regexp [lindex [getTMarks] 0] "filterLend.*"]
  337.         set finish [lindex [lindex [lindex [getTMarks] 0] $ind] 2]
  338.         gotoTMark "filterLnext"
  339.         set pos [$unitStart [getPos]]
  340.         set next [$unitEnd $pos]
  341.     }
  342.     removeTMark "filterLend"
  343.     removeTMark "filterLnext"
  344. }
  345.  
  346.  
  347. proc filterParagraphs {{cmd 0}} { filterLines $cmd 1 }
  348.  
  349. # WARNING: deselecting sets the mark to selEnd
  350. proc sortParagraphs {{from -1} {to -1}} {
  351.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  352.     if {$from >= $to} return
  353.     joinRegion {$from $to}
  354.     select [getPos] [nextLineStart [getMark]]
  355.     sortLines
  356.     select [getPos] [getPos]
  357.     regsubInRegion [getPos] [getMark] "\r" "\r\r" 
  358.     wrapRegion
  359. }
  360.  
  361. #
  362. # Sample
  363. #
  364. proc filterRegion {{from -1} {to -1} {cmd 0} {newwin 0}} {
  365.     if {$cmd == 0} {
  366.       if {[catch { prompt "Eval command: " "" } cmd]} { return }
  367.     }
  368.     if {![string length $cmd]} return
  369.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  370.     if {$from >= $to} return
  371.     set pos [getPos]
  372.     set text [getText $from $to]
  373.     set text [$cmd $text]
  374.     replaceText $from $to $text "\r"
  375.     goto $pos
  376. }
  377.  
  378.  
  379. #
  380. set lastEvaled ""
  381. proc evaluate {} {
  382.     global lastEvaled
  383.     if {[string length $lastEvaled]} {
  384.         set p "M-x ($lastEvaled): "
  385.     } else {
  386.         set p "M-x: "
  387.     }
  388.     if {[catch {statusPrompt $p} text]} {return}
  389.     if {![string length $text]} {set text $lastEvaled}
  390.     $text
  391.     set lastEvaled $text
  392. }
  393.  
  394.  
  395. # First, define macros to bypass the electric braces.
  396. proc ordLeftBrace {} {
  397.     insertText "        \{"
  398. }
  399. bind {'['} <cs> ordLeftBrace
  400.  
  401. proc ordRightBrace {} {
  402.     insertText "\}"
  403.     blink [matchIt "\}" [expr [getPos]-1]]
  404. }
  405. bind {']'} <cs> ordRightBrace
  406.     
  407. proc quoteWord {} {
  408.     backwardWord
  409.     insertText "'"
  410.     forwardWord
  411.     insertText "'"
  412. }
  413. bind ''' <z> quoteWord
  414.  
  415. #================================================================================
  416.  
  417. proc tomac {fname} {
  418.     set fd [open $fname "r"]
  419.     set text [read $fd]
  420.     close $fd
  421.     set fd [open $fname "w"]
  422.     regsub "\n" $text "\r" text
  423.     puts -nonewline $fd $text
  424.     close $fd
  425. }
  426.  
  427. proc tounix {fname} {
  428.     set fd [open $fname "r"]
  429.     set text [read $fd]
  430.     close $fd
  431.     set fd [open $fname "w"]
  432.     regsub "\r" $text "\n" text
  433.     puts -nonewline $fd $text
  434.     close $fd
  435. }
  436.  
  437. #================================================================================
  438. # Sets marks for file.
  439.  
  440. set mpos("") ""
  441.  
  442. proc markFile {} {
  443.     global mode
  444.  
  445.     case $mode in {
  446.         "C" {return [cMarkFile]}
  447.         "TeX" {return [texMarkFile]}
  448.          "C++" {return [c++MarkFile]}
  449.         "Csh" {return [cshMarkFile]}
  450.         "Tcl" {return [tclMarkFile]}
  451.         "BRWZ" {return [browseMarkFile]}
  452.     }
  453. }
  454.  
  455.  
  456.